home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / envcalc.com / ENVCALC.PGM < prev    next >
Encoding:
Text File  |  1991-03-15  |  4.1 KB  |  221 lines
  1. program envcalc;
  2.  
  3. {$V-}
  4.  
  5. uses objects, {strg,uwstring,} uwcalc;
  6.  
  7. {}
  8.  
  9. procedure strupr(var s:string); 
  10. var
  11.  x:byte;
  12. begin
  13.  for x:=1 to length(s) do s[x]:=upcase(s[x])
  14. end;
  15.  
  16. procedure ssplit(entry:string; sep:char; var head,tail:string);
  17. var
  18.  v:byte;
  19. begin
  20.  head:=entry; tail:='';
  21.  v:=pos(sep,entry);
  22.   if (v=0) then EXIT;
  23.  head:=copy(entry,1,v-1);
  24.  tail:=copy(entry,v+1,255)
  25. end;
  26.  
  27. function dictpos(var dict:string; word:string; wsep:char):byte;
  28. var
  29.  v,x,z:byte;
  30. begin
  31.  dictpos:=0;
  32.   z:=pos(word+wsep,dict);
  33.    if (z=0) then exit;
  34.   inc(z,length(word));
  35.   v:=0; x:=0;
  36.   repeat
  37.    inc(v);
  38.    if (dict[v]=wsep) then inc(x)
  39.   until (v=z);
  40.  dictpos:=x
  41. end;
  42.  
  43. {}
  44.  
  45. const
  46.  ecsep='=';
  47.  eclft='[';
  48.  ecrgt=']';
  49.  eclen=127;
  50.  
  51. type
  52.  tenvstr=string[127];
  53.  penvstr=^tenvstr;
  54.  
  55. type
  56.  penvctn=^tenvctn;
  57.  tenvctn=object(tcollection)
  58.   procedure freeitem(item:pointer);virtual;
  59.  
  60.   function  fndtoken(atoken:tenvstr):pointer;
  61.   procedure getvalue(atoken:tenvstr; var value:tenvstr);
  62.   procedure setvalue(atoken:tenvstr; var value:tenvstr);
  63.   procedure getentry(index:integer; var token,value:tenvstr);
  64.   procedure echovar(var atoken:tenvstr);
  65.   procedure echostr(var acmdln:string);
  66.  end;
  67.  
  68. procedure tenvctn.freeitem;
  69. begin
  70.  disposestr(item)
  71. end;
  72.  
  73. function  tenvctn.fndtoken;
  74.  function matches(item:pointer):boolean;far;
  75.  begin
  76.   matches:=(copy(pstring(item)^,1,pos(ecsep,pstring(item)^)-1)=atoken)
  77.  end;
  78. begin
  79.  strupr(atoken);
  80.  fndtoken:=firstthat(@matches)
  81. end;
  82.  
  83. procedure tenvctn.getvalue;
  84. var
  85.  p:pointer;
  86. begin
  87.  p:=fndtoken(atoken);
  88.  if (p=nil)
  89.   then value:=''
  90.   else value:=copy(pstring(p)^,pos(ecsep,pstring(p)^)+1,eclen)
  91. end;
  92.  
  93. procedure tenvctn.setvalue;
  94. var
  95.  p:pointer;
  96. begin
  97.  strupr(atoken);
  98.  
  99.  p:=fndtoken(atoken);
  100.  if (p<>nil) then free(p);
  101.  
  102.  if (value='') then EXIT;
  103.  
  104.  insert(newstr(atoken+ecsep+value))
  105. end;
  106.  
  107. procedure tenvctn.getentry;
  108.  {-Index -MUST- be in the range 0..pred(count).}
  109. begin
  110.  ssplit(pstring(at(index))^,ecsep,token,value)
  111. end;
  112.  
  113. procedure tenvctn.echovar;
  114.  {-Returns value if atoken defined.}
  115.  { Otherwise atoken is not altered.}
  116. var
  117.  value:tenvstr;
  118. begin
  119.  value:='';
  120.  getvalue(atoken,value);
  121.  if (value<>'') then atoken:=value
  122. end;
  123.  
  124. procedure tenvctn.echostr;
  125.  {-Replaces any [token]s with their values.} 
  126. var
  127.  v,x,z:byte;
  128.  value:tenvstr;
  129. label
  130.  scan;
  131. begin
  132.  v:=0;
  133.  scan:
  134.   z:=v;
  135.   v:=pos(eclft,copy(acmdln,z+1,255)); 
  136.    if (v=0) then EXIT;
  137.  
  138.   x:=pos(ecrgt,copy(acmdln,z+v+1,255)); 
  139.    if (x=0) then EXIT;
  140.   getvalue(copy(acmdln,z+v+1,x-1),value);
  141.  
  142.   if (value='')   {1234[6789]1234[6789]}
  143.    then v:=z+v+x
  144.    else begin
  145.     system.delete(acmdln,z+v,x+1);
  146.      {strins(acmdln,value,z+v,255);}
  147.     system.insert(value,acmdln,z+v);
  148.     v:=z+v+length(value)
  149.    end;
  150.  goto scan
  151. end;
  152.  
  153. {}
  154.  
  155. var
  156.  env:tenvctn;
  157.  s,token,value:string;
  158.  r:real;
  159.  x:byte;
  160. const
  161.  cmset=1;
  162.  cmecho=2;
  163.  cmcalc=3;
  164.  cmlet=4;
  165.  vocab:string='SET,ECHO,CALC,LET,';
  166.  
  167. procedure reply(atoken:tenvstr);
  168. begin
  169.  env.getvalue(atoken,value);
  170.  strupr(atoken);
  171.  writeln('> ',atoken,ecsep,value)
  172. end;
  173.  
  174. BEGIN
  175.  writeln('Available commands include SET ECHO CALC and LET.');
  176.  env.init(16,16);
  177.  with env do repeat
  178.   write('? '); readln(s);
  179.  
  180.   ssplit(s,' ',token,value);
  181.   strupr(token);
  182.  
  183.   case dictpos(vocab,token,',') of
  184.    cmset:
  185.     begin
  186.      if (value<>'')
  187.       then begin
  188.        ssplit(value,ecsep,token,value);
  189.        setvalue(token,value);
  190.        if (value<>'') then reply(token)
  191.       end
  192.       else if (count>0) 
  193.        then for x:=0 to pred(count) do
  194.         writeln('> ',pstring(at(x))^)
  195.     end;
  196.    cmecho:
  197.     begin
  198.      echostr(value); writeln(value)
  199.     end;
  200.    cmcalc:
  201.     begin
  202.      echostr(value); stdsub(value); value:=value+csequal;
  203.      if calcstr(r,value)
  204.       then writeln('> ',value)
  205.       else writeln('! ',cserrst)
  206.     end;
  207.    cmlet:
  208.     begin
  209.      ssplit(value,ecsep,token,value);
  210.      echostr(value); stdsub(value); value:=value+csequal;
  211.      if calcstr(r,value)
  212.       then setvalue(token,value)
  213.       else setvalue(token,cserrst);
  214.      reply(token)
  215.     end
  216.   end
  217.  
  218.  until (s='');
  219.  env.done
  220. END.
  221.